(DECLARE (SPECIAL $%DOTFLG %%DTIME %%GCTIME %%PACO %%PAFN %%PAFS %%SPEAK %%TIME
		  %PREVFN% *NOPOINT *NOPOINTDSK *RAISE *RAISEDSK ALLFNS ALLVALS
		  BASE BPEND BPORG CATCH COMMENTFLG DSKIN DSKLENGTH DSKOUT EDITV
		  FILBAK FILBAKBAK FILPRO GETDEF LAPLST LAPSLST LASTWORD MEMBFN
		  NOCALL OBLIST PP PRINLEV REMOB SAVE THROW)
	 (NOCALL SELECTQ1 SUBPR MEMCDR %FILEXT %PRINA %DUMPATOMS %SUBSTR %%PACO
		 %%PAFN %%PAFS)
	 (GLOBALMACRO PLUS DIFFERENCE TIMES QUOTIENT LESSP GREATERP MIN MAX
		      MCONS PUSH POP INCR DECR NOTANY NOTEVERY F:L DO RPTQ))

{;; System macros and supporting functions:⎇

(DEFPROP PLUS (LAMBDA (L) (*EXPAND L '*PLUS)) MACRO)

(DEFPROP DIFFERENCE (LAMBDA (L) (*EXPAND L '*DIF)) MACRO)

(DEFPROP TIMES (LAMBDA (L) (*EXPAND L '*TIMES)) MACRO)

(DEFPROP QUOTIENT (LAMBDA (L) (*EXPAND L '*QUO)) MACRO)

(DEFPROP LESSP
 (LAMBDA (L)
  (LIST '*LESS
	(*EXPAND1 (CDR (REVERSE (CDR L)))
		  '(LAMBDA (X Y) (COND [(AND X [*LESS X Y]) Y])))
	(CAR (LAST L))))
 MACRO)

(DEFPROP GREATERP
 (LAMBDA (L)
  (LIST '*GREAT
	(*EXPAND1 (CDR (REVERSE (CDR L)))
		  '(LAMBDA (X Y) (COND [(AND X [*GREAT X Y]) Y])))
	(CAR (LAST L))))
 MACRO)

(DEFPROP MIN (LAMBDA (L) (*EXPAND L '*MIN)) MACRO)

(DEFPROP MAX (LAMBDA (L) (*EXPAND L '*MAX)) MACRO)

(DEFPROP MCONS (LAMBDA (L) (*EXPAND2 (CDR L) 'CONS)) MACRO)

(DEFPROP PUSH
 (LAMBDA (L) (LIST 'SETQ (CADR L) (LIST 'CONS (CADDR L) (CADR L))))
 MACRO)

(DEFPROP POP
 (LAMBDA (L)
  (LIST 'PROG1
	(LIST 'CAR (CADR L))
	(LIST 'SETQ (CADR L) (LIST 'CDR (CADR L)))))
 MACRO)

(DEFPROP INCR
 (LAMBDA (L) (LIST 'SETQ (CADR L) (LIST 'ADD1 (CADR L))))
 MACRO)

(DEFPROP DECR
 (LAMBDA (L) (LIST 'SETQ (CADR L) (LIST 'SUB1 (CADR L))))
 MACRO)

(DEFPROP NOTANY (LAMBDA (L) (LIST 'NOT (CONS 'SOME (CDR L)))) MACRO)

(DEFPROP NOTEVERY (LAMBDA (L) (LIST 'NOT (CONS 'EVERY (CDR L)))) MACRO)

(DEFPROP F:L (LAMBDA (L) (LIST 'FUNCTION (CONS 'LAMBDA (CDR L)))) MACRO)

(DEFPROP DO (LAMBDA (L) (%DO (CDR L))) MACRO)

(DEFPROP RPTQ
 (LAMBDA (L) (%DO (CONS 'FOR (CONS 'RPTN (CONS 'RPT (CDR L))))))
 MACRO)

(DEFPROP %DO
 (LAMBDA (%L)
  (SELECTQ [CAR %L]
	   [(UNTIL WHILE)
	    (SUBPAIR '(X Y)
		     (LIST (COND [(EQ (CAR %L) 'UNTIL) (CADR %L)]
				 [T (LIST 'NOT (CADR %L))])
			   (CDDR %L))
		     '(PROG (DO!V)
		       DO!L (AND X [RETURN DO!V])
			    (SETQ DO!V (PROGN . Y))
			    (GO DO!L)))]
	   [FOR (SELECTQ [CADDR %L]
			 [(IN ON)
			  (SUBPAIR '(X Y L E)
				   (LIST (CADR %L)
					 (CDDDDR %L)
					 (CADDDR %L)
					 (COND [(EQ (CADDR %L) 'IN) '(CAR DO!L)]
					       [T 'DO!L]))
				   '((LAMBDA (DO!L)
				      (PROG (X DO!V)
				       DO!L (AND [NULL DO!L] [RETURN DO!V])
					    (SETQ X E)
					    (SETQ DO!L (CDR DO!L))
					    (SETQ DO!V (PROGN . Y))
					    (GO DO!L)))
				     L))]
			 [RPT (SUBPAIR '(X Y E)
				       (LIST (CADR %L) (CDDDDR %L) (CADDDR %L))
				       '((LAMBDA (X DO!L)
					  (PROG (DO!V)
					   DO!L (AND [*GREAT X DO!L]
						     [RETURN DO!V])
						(SETQ DO!V (PROGN . Y))
						(SETQ X (ADD1 X))
						(GO DO!L)))
					 1. 
					 E))]
			 [ERROR '"BAD FORMAT - DO"])]
	   [CONS 'PROGN %L]))
 EXPR)

(DEFPROP *EXPAND2
 (LAMBDA (L FN)
  (COND [(NULL (CDR L)) (CAR L)]
	[T (LIST FN (CAR L) (*EXPAND2 (CDR L) FN))]))
 EXPR)

(DEFPROP UNMACEXPAND
 (LAMBDA (X)
  (PROG (XX)
	(COND [(PATOM X) (RETURN X)]
	      [(EQ (CAR X) 'MACROEXPANSION)
	       (RPLACA X (CAADDR X))
	       (RPLACD X (CDADDR X))])
	(SETQ XX X)
   LOOP (UNMACEXPAND (CAR XX))
	(COND [(CONSP (SETQ XX (CDR XX))) (GO LOOP)] [T (RETURN X)])))
 EXPR)

{;; New names for old friends:⎇

(DEFP + *PLUS SUBR)

(DEFP - *DIF SUBR)

(DEFP * *TIMES SUBR)

(DEFP // *QUO SUBR)

(DEFP +I ADD1 SUBR)

(DEFP -I SUB1 SUBR)

(DEFP = EQUAL SUBR)

(DEFP LT *LESS SUBR)

(DEFP GT *GREAT SUBR)

(DEFP PUT PUTPROP SUBR)

(DEFP PRIN PRIN1 SUBR)

(DEFP READL LINEREAD SUBR)

(DEFP MAPL MAPLIST LSUBR)

(DEFP MAPCL MAPCAR LSUBR)

(DEFP CONSCOUNT SPEAK SUBR)

{;; Original UCI LISP functions <with Rutgers modifications>:⎇

(DEFPROP DIR
 (LAMBDA (%UFD)
  (PROG (%LIST)
	(SETQ %UFD (INC (UFDINP (GENSYM) %UFD) NIL))
	(ERRSET (PROG NIL LOOP (SETQ %LIST (CONS (RDFILE) %LIST)) (GO LOOP)))
	(INC %UFD T)
	(RETURN %LIST)))
 EXPR)

(DEFPROP *RENAME (LAMBDA (X Y) (EVAL (CONS 'RENAME (APPEND X Y)))) EXPR)

(DEFPROP FILBAK
 (LAMBDA (FILE BAK)
  (PROG (NAME EXT)
	(COND [(ATOM FILE) (SETQ NAME (CAR (SETQ FILE (NCONS FILE))))]
	      [(ATOM (CDR FILE))
	       (SETQ EXT (CDR FILE))
	       (SETQ NAME (CAAR (SETQ FILE (NCONS FILE))))]
	      [T (SETQ NAME (CADR FILE))
		 (COND [(CONSP NAME)
			(SETQ EXT (CDR NAME))
			(SETQ NAME (CAR NAME))])])
	(SETQ BAK (NCONS (CONS NAME (%FILEXT EXT BAK))))
	(AND FILBAKBAK 
	     [*RENAME BAK (NCONS (CONS NAME (%FILEXT EXT FILBAKBAK)))])
	(APPLY# 'DELETE BAK)
	(RETURN (*RENAME FILE BAK))))
 EXPR)

(DEFPROP %FILEXT
 (LAMBDA (OLDEXT NEWEXT)
  (COND [(NULL OLDEXT) NEWEXT]
	[T (SETQ NEWEXT (AEXPLODE NEWEXT))
	   (READLIST (NCONC NEWEXT 
			    (NTH (AEXPLODE OLDEXT) (ADD1 (LENGTH NEWEXT)))))]))
 EXPR)

(DEFV FILBAK Q)

(DEFV FILBAKBAK QBK)

(DEFPROP DE (LAMBDA (L) (%DEFINE L 'EXPR)) FEXPR)

(DEFPROP DF (LAMBDA (L) (%DEFINE L 'FEXPR)) FEXPR)

(DEFPROP DM (LAMBDA (L) (%DEFINE L 'MACRO)) FEXPR)

(DEFPROP DV
 (LAMBDA (L)
  (SET (CAR L) (CADR L))
  (SETQ ALLVALS (ENTER (CAR L) ALLVALS))
  (SETQ EDITV (CAR L)))
 FEXPR)

(DEFPROP %DEFINE
 (LAMBDA (L P)
  (PROG (X V R)
	(COND [(OR [*LESS (LENGTH L) 3.]
		   [NOT (LITATOM (SETQ X (CAR L)))]
		   [AND [NOT (CONSP (SETQ V (CADR L)))]
			[NOT (AND [LITATOM V] [EQ P 'EXPR])]])
	       (ERROR '"ILLEGAL FORMAT - DE, DF, DM")])
	(SETQ L (CDDR L))
	(SETQ R
	      (COND [(SETQ R (GETL X '(EXPR FEXPR SUBR FSUBR LSUBR MACRO)))
		     (COND [SAVE (APPLY# 'SAVE (NCONS X))]
			   [T (UNBREAK! X) (REMPROP X (CAR R))])
		     (LIST X 'Redefined)]
		    [T X]))
	(PUTPROP X (CONS 'LAMBDA (CONS V L)) P)
	(SETQ ALLFNS (ENTER X ALLFNS))
	(SETQ LASTWORD X)
	(RETURN R)))
 EXPR)

(DEFV SAVE T)

(DEFV ALLFNS NIL)

(DEFV ALLVALS NIL)

(DEFPROP SAVE
 (LAMBDA (X)
  (PROG (D)
	(COND [(SETQ D
		     (GETL (SETQ X (CAR X))
			   '(EXPR FEXPR SUBR FSUBR LSUBR MACRO)))
	       (UNBREAK! X)
	       (PUTPROP X (CONS (CAR D) (CADR D)) 'SAVE)
	       (REMPROP X (CAR D))
	       (RETURN X)])))
 FEXPR)

(DEFPROP UNSAVE
 (LAMBDA (X)
  (PROG (D1 D2)
	(COND [(SETQ D1 (GET (SETQ X (CAR X)) 'SAVE))
	       (UNBREAK! X)
	       (AND [SETQ D2 (GETL X '(EXPR FEXPR SUBR FSUBR LSUBR MACRO))]
		    [REMPROP X (CAR D2)])
	       (PUTPROP X (CDR D1) (CAR D1))
	       (REMPROP X 'SAVE)
	       (RETURN X)])))
 FEXPR)

(DEFPROP DRM (LAMBDA (L) (%DEREAD (CHRVAL (CAR L)) (CADR L) 10.)) FEXPR)

(DEFPROP DSM (LAMBDA (L) (%DEREAD (CHRVAL (CAR L)) (CADR L) 11.)) FEXPR)

(DEFPROP %DEREAD
 (LAMBDA (CHAR FUNC BITS)
  (SETQ CHAR (IASCII CHAR))
  (COND [(NULL FUNC) (SETCHR CHAR 21.) (REMPROP CHAR 'READMACRO)]
	[T (PUTPROP CHAR FUNC 'READMACRO) (SETCHR CHAR BITS)])
  CHAR)
 EXPR)

(DEFPROP DSKIN
 (LAMBDA (%L)
  (PROG (%CH)
	(SETQ %CH (APPLY# 'INPUT (CONS (GENSYM) %L)))
	(%READIN %CH DSKIN)
	(RETURN 'Files-Loaded)))
 FEXPR)

(DEFV DSKIN T)

(DEFPROP %READIN
 (LAMBDA (CHAN PRINT)
  (PROG (*RAISE X SAWLAP)
	(SETQ *RAISE *RAISEDSK)
	(SETQ CHAN (INC CHAN NIL))
	(AND PRINT [LINES 0.])
	(SETQ X
	      (ERRSET (PROG (Y)
		       LOOP (SETQ Y (READ))
			    (COND [(CONSP Y)
				   (AND [EQ (CAR Y) 'LAP] [SETQ SAWLAP T])
				   (AND [CONSP (CDR Y)]
					[LITATOM (CADR Y)]
					[UNBREAK! (CADR Y)])])
			    (SETQ Y (EVAL Y))
			    (COND [(EQ PRINT 'PRINT) (PRINT Y)]
				  [(AND PRINT Y) (MSG Y 1.)])
			    (GO LOOP))
		      ERRORX))
	(AND PRINT [LINES 0.])
	(INC CHAN T)
	(AND SAWLAP 
	     [MAPATOMS (FUNCTION
			(LAMBDA (Y)
			 {;; If any UNDEF props left hanging around by LAP they
			     must reference undefined NOCALLs; Warn user but
			     flag so it won't be printed twice⎇
			 (AND [GET Y 'UNDEF]
			      [NOT (GET Y '%READIN)]
			      [PUTPROP Y T '%READIN]
			      [TTYMSG -1. "*WARNING - NOCALL Function " Y
				      " Not Yet Defined." T])))])
	(AND [NEQ X '$EOF$] [ERR X])))
 EXPR)

(DEFV *RAISEDSK NIL)

(DEFPROP DSKOUT
 (LAMBDA (%%L)
  ((LAMBDA (FILPRO)
    (PROG (%DEV %FNAME *NOPOINT PP)
	  (SETQ *NOPOINT *NOPOINTDSK)
	  (AND [SETQ PP DSKOUT] [LINES 0.])
	  (COND [(%DEVP (SETQ %DEV (CAR %%L))) (SETQ %%L (CDR %%L))]
		[T (SETQ %DEV 'DSK:)])
	  (COND [(LOOKUP %DEV (SETQ %FNAME (CAR %%L)))
		 (SETQ FILPRO NIL)     {; Use existing protection⎇
		 (AND FILBAK 
		      [NULL (SETQ FILPRO (FILBAK (LIST %DEV %FNAME) FILBAK))]
		      [TTYMSG -1. "No Backup: " %FNAME T])])
	  (SETQ %DEV (OUTC (APPLY# 'OUTPUT (LIST (GENSYM) %DEV %FNAME)) NIL))
	  (LINELENGTH DSKLENGTH)
	  (COND [(NULL (SETQ %%L (CDR %%L)))
		 (SETQ %FNAME
		       (READLIST (NCONC (AEXPLODE (COND [(ATOM %FNAME) %FNAME]
							[T (CAR %FNAME)]))
					'(F N S))))
		 (SETQ %%L (LIST %FNAME))
		 (COND [(NOT (BOUNDP %FNAME))
			(SET %FNAME (SORT (APPEND ALLVALS ALLFNS) NIL T))])])
       L1 (COND [(ATOM (CAR %%L)) (EVAL (LIST 'PPL (CAR %%L)))]
		[T (EVAL (CAR %%L))])
	  (AND [SETQ %%L (CDR %%L)] [GO L1])
	  (OUTC %DEV T)
	  (AND DSKOUT [LINES 0.])
	  (RETURN 'File-Dumped)))
   FILPRO))
 FEXPR)

(DEFV DSKOUT T)

(DEFV *NOPOINTDSK NIL)

(DEFV DSKLENGTH 80.)

(PROGN (REMPROP 'LPTLENGTH 'VALUE) (DEFP LPTLENGTH DSKLENGTH VALUE))

(DEFPROP %DEVP
 (LAMBDA (X)
  (OR [EQ (ANTHCHAR X -1.) 58.] [AND [CONSP X] [CONSP (CDR X)]]))
 EXPR)

(DEFPROP TCONC
 (LAMBDA (P X)
  (COND [(NULL P) (CONS (SETQ X (NCONS X)) X)]
	[(ATOM P) (ERROR (LIST P '"BAD ARGUMENT - TCONC"))]
	[(CDR P) (RPLACD P (CDR (RPLACD (CDR P) (NCONS X))))]
	[T (RPLACA (RPLACD P (SETQ X (NCONS X))) X)]))
 EXPR)

(DEFPROP LCONC
 (LAMBDA (PTR X)
  (PROG (XX)
	(COND [(NULL X) (RETURN PTR)]
	      [(OR [ATOM X] [CDR (SETQ XX (LAST X))]) (GO ERROR)]
	      [(NULL PTR) (RETURN (CONS X XX))]
	      [(ATOM PTR) (SETQ X PTR) (GO ERROR)]
	      [(NULL (CAR PTR)) (RETURN (RPLACA (RPLACD PTR XX) X))]
	      [T (RPLACD (CDR PTR) X) (RETURN (RPLACD PTR XX))])
  ERROR (ERROR (LIST X '"BAD ARGUMENT - LCONC"))))
 EXPR)

(DEFPROP DREVERSE
 (LAMBDA (L)
  (PROG (Y Z)
     L1 (COND [(ATOM (SETQ Y L)) (RETURN Z)])
	(SETQ L (CDR L))
	(SETQ Z (RPLACD Y Z))
	(GO L1)))
 EXPR)

(DEFPROP REMOVE
 (LAMBDA (ELT LIST)
  (COND [(ATOM LIST) LIST]
	[(EQUAL (CAR LIST) ELT) (REMOVE ELT (CDR LIST))]
	[(CONS (CAR LIST) (REMOVE ELT (CDR LIST)))]))
 EXPR)

(DEFPROP DREMOVE
 (LAMBDA (X L)
  (COND [(ATOM L) NIL]
	[(EQ X (CAR L))
	 (COND [(CDR L) (RPLACA L (CADR L)) (RPLACD L (CDDR L)) (DREMOVE X L)])]
	[T (PROG (Z)
		 (SETQ Z L)
	      LP (COND [(ATOM (CDR L)) (RETURN Z)]
		       [(EQ X (CADR L)) (RPLACD L (CDDR L))]
		       [T (SETQ L (CDR L))])
		 (GO LP))]))
 EXPR)

(DEFPROP TAILP
 (LAMBDA (X Y)
  (AND X 
       [PROG NIL
	  LP (COND [(ATOM Y) (RETURN NIL)] [(EQ X Y) (RETURN X)])
	     (SETQ Y (CDR Y))
	     (GO LP)]))
 EXPR)

(DEFPROP ASSOC#
 (LAMBDA (A B)
  (PROG NIL
     L1 (COND [(NULL B) (RETURN NIL)] [(EQUAL A (CAAR B)) (RETURN (CAR B))])
	(SETQ B (CDR B))
	(GO L1)))
 EXPR)

(DEFPROP PRINTLEV (LAMBDA ($%X $%N) (TERPRI) (PRINLEV $%X $%N) $%X) EXPR)

(DEFPROP PRINLEV
 (LAMBDA ($%X $%N)
  {;; PRINLEV now uses PRINA so atomic symbols aren't broken over lines;
      Printing resumes in column PRINLEV of the next line⎇
  (COND [(PATOM $%X) (PRINA $%X PRINLEV)]
	[(EQ %PREVFN% $%X) (PRINAC '"\#\" PRINLEV)]
	[(AND [NULL COMMENTFLG] [LITATOM (CAR $%X)] [GET (CAR $%X) 'COMMENT])
	 (PRINAC '"*COMMENT*" PRINLEV)]
	[(EQ $%N 0.) (PRINAC '& PRINLEV)]
	[T (PROG ($%KK $%CL)
		 (AND [*LESS (CHRCT) 12.] [TAB PRINLEV])
		 (PRINC (COND [$%DOTFLG (SETQ $%DOTFLG NIL) '"... "] [T '"("]))
		 (PRINLEV (CAR $%X) (SUB1 $%N))
		 (SETQ $%KK $%X)
	      LP (COND [(MEMCDR $%X $%KK)
			(COND [$%CL (PRINAC '" ...]" PRINLEV) (RETURN NIL)]
			      [T (SETQ $%CL T)])])
		 (SETQ $%KK (CDR $%KK))
		 (COND [(NULL $%KK) (TYOA 41. PRINLEV) (RETURN NIL)]
		       [(PATOM $%KK)
			(PRINAC '" . " PRINLEV)
			(PRINA $%KK PRINLEV)
			(TYOA 41. PRINLEV)
			(RETURN NIL)])
		 (SPACES 1. PRINLEV)
		 (COND [(NOT (PATOM (CAR $%KK)))
			(PRINLEV (CAR $%KK) (SUB1 $%N))]
		       [T (PRINA (CAR $%KK) PRINLEV)])
		 (GO LP))]))
 EXPR)

(DEFV PRINLEV 6.)

(DEFPROP MEMCDR
 (LAMBDA (%X% %Y%)
  (PROG NIL
     L1 (COND [(EQ %X% (CDR %Y%)) (RETURN T)] [(EQ %X% %Y%) (RETURN NIL)])
	(SETQ %X% (CDR %X%))
	(GO L1)))
 EXPR)

(DEFV %PREVFN% NIL)

(DEFV $%DOTFLG NIL)

(DEFPROP LSUBST
 (LAMBDA (X Y Z)
  (COND [(NULL Z) NIL]
	[(PATOM Z) (COND [(EQ Y Z) X] [T Z])]
	[(EQUAL Y (CAR Z)) (NCONC (COPY X) (LSUBST X Y (CDR Z)))]
	[T (CONS (LSUBST X Y (CAR Z)) (LSUBST X Y (CDR Z)))]))
 EXPR)

(DEFPROP SELECTQ
 (LAMBDA (SELCQ)
  (APPLY# 'PROGN (SELECTQ1 (EVAL (CAR SELCQ)) (CDR SELCQ))))
 FEXPR)

(DEFPROP SELECTQ1
 (LAMBDA (M L)
  (PROG (C)
     LP (SETQ C L)
	(COND [(NULL (SETQ L (CDR L))) (RETURN C)]
	      [(OR [EQ (CAR (SETQ C (CAR C))) M]
		   [AND [CONSP (CAR C)] [MEMQ M (CAR C)]])
	       (RETURN (CDR C))])
	(GO LP)))
 EXPR)

(DEFPROP SUBLIS
 (LAMBDA (ALST EXPR) (COND [ALST (SUBPR EXPR ALST NIL)] [T EXPR]))
 EXPR)

(DEFPROP SUBPAIR
 (LAMBDA (OLD NEW EXPR)
  (COND [OLD (SUBPR EXPR OLD (OR NEW '[NIL]))] [T EXPR]))
 EXPR)

(DEFPROP SUBPR
 (LAMBDA (EXPR L1 L2)
  (PROG (D A)
	(COND [(ATOM EXPR) (GO LP)]
	      [(SETQ D (CDR EXPR)) (SETQ D (SUBPR D L1 L2))])
	(SETQ A (SUBPR (CAR EXPR) L1 L2))
	(RETURN (COND [(OR [NEQ A (CAR EXPR)] [NEQ D (CDR EXPR)]) (CONS A D)]
		      [T EXPR]))
     LP (COND [(NULL L1) (RETURN EXPR)]
	      [L2 (COND [(EQ EXPR (CAR L1)) (RETURN (CAR L2))])]
	      [T (COND [(EQ EXPR (CAAR L1)) (RETURN (CDAR L1))])])
	(SETQ L1 (CDR L1))
	(AND L2 [SETQ L2 (OR [CDR L2] '[NIL])])
	(GO LP)))
 EXPR)

(DEFPROP DSUBST
 (LAMBDA (X Y Z)
  (PROG (B)
	(COND [(EQ Y (SETQ B Z)) (RETURN (COPY X))])
     LP (COND [(PATOM Z) (RETURN B)]
	      [(COND [(LITATOM Y) (EQ Y (CAR Z))] [T (EQUAL Y (CAR Z))])
	       (RPLACA Z (COPY X))]
	      [T (DSUBST X Y (CAR Z))])
	(COND [(AND Y [EQ Y (CDR Z)]) (RPLACD Z (COPY X)) (RETURN B)])
	(SETQ Z (CDR Z))
	(GO LP)))
 EXPR)

(DEFPROP RETFROM
 (LAMBDA (FUN VAL)
  (COND [(SETQ FUN (STKSRCH FUN (SPDLPT) NIL)) (OUTVAL FUN VAL)]
	[T (ERROR (LIST FUN '"NO EVAL BLIP - RETFROM"))]))
 EXPR)

(DEFPROP LDIFF
 (LAMBDA (X Y)
  (COND [(EQ X Y) NIL]
	[(NULL Y) X]
	[T (PROG (V Z)
		 (SETQ Z (SETQ V (NCONS (CAR X))))
	    LOOP (SETQ X (CDR X))
		 (COND [(EQ X Y) (RETURN Z)]
		       [(NULL X) (ERROR '"NOT A TAIL - LDIFF")])
		 (SETQ V (CDR (RPLACD V (NCONS (CAR X)))))
		 (GO LOOP))]))
 EXPR)

(DEFPROP NTH
 (LAMBDA (X N)
  (COND [(*GREAT 1. N) (CONS NIL X)]
	[T (PROG NIL
	      LP (COND [(OR [ATOM X] [EQ N 1.]) (RETURN X)])
		 (SETQ X (CDR X))
		 (SETQ N (SUB1 N))
		 (GO LP))]))
 EXPR)

(DEFPROP SUBST
 (LAMBDA (X Y S)
  (COND [(EQUAL Y S) X]
	[(ATOM S) S]
	[T (CONS (SUBST X Y (CAR S)) (SUBST X Y (CDR S)))]))
 EXPR)

(DEFPROP COPY (LAMBDA (X) (SUBST 0. 0. X)) EXPR)

(DEFPROP PUTSYM
 (LAMBDA (L)
  (MAPC (FUNCTION
	 (LAMBDA (X)
	  (COND [(ATOM X) (*PUTSYM X X)] [T (*PUTSYM (CAR X) (EVAL (CADR X)))]))
	 )
	L))
 FEXPR)

(DEFPROP GETSYM
 (LAMBDA (L0)
  (MAPCAR (FUNCTION
	   (LAMBDA (X)
	    (PROG (V)
		  (SETQ V (*GETSYM X))
		  (COND [V (PUTPROP X (NUMVAL V) (CAR L0))]
			[T (TTYMSG -1. X " not in Symbol Table." T)])
		  (RETURN V))))
	  (CDR L0)))
 FEXPR)

(DEFPROP RPUTSYM
 (LAMBDA (L)
  (MAPC (FUNCTION
	 (LAMBDA (X)
	  (COND [(ATOM X) (*RPUTSYM X X)]
		[T (*RPUTSYM (CAR X) (EVAL (CADR X)))])))
	L))
 FEXPR)

(DEFPROP RGETSYM
 (LAMBDA (L0)
  (MAPCAR (FUNCTION
	   (LAMBDA (X)
	    (PROG (V)
		  (SETQ V (*RGETSYM X))
		  (COND [V (PUTPROP X (NUMVAL V) (CAR L0))]
			[T (TTYMSG -1. X " not in Symbol Table." T)])
		  (RETURN V))))
	  (CDR L0)))
 FEXPR)

{;; Rutgers additions:⎇

{;; New predicates:⎇

(DEFPROP LE (LAMBDA (X Y) (NOT (*GREAT X Y))) EXPR)

(DEFPROP GE (LAMBDA (X Y) (NOT (*LESS X Y))) EXPR)

(DEFPROP =0 (LAMBDA (X) (EQ X 0.)) EXPR)

(DEFPROP INP
 (LAMBDA (X Y)
  (COND [(EQ X Y) T]
	[(ATOM Y) NIL]
	[(INP X (CAR Y)) T]
	[T (INP X (CDR Y))]))
 EXPR)

{;; New list-manipulation and property list functions:⎇

(DEFPROP ATTACH
 (LAMBDA (X Y)
  (COND [(CONSP Y) (RPLACD Y (CONS (CAR Y) (CDR Y))) (RPLACA Y X)]
	[(NULL Y) (LIST X)]
	[T (ERROR (LIST Y '"CAN'T ATTACH TO ATOM"))]))
 EXPR)

(DEFPROP ENTER
 (LAMBDA (V L) (COND [(MEMBFN V L) L] [T (CONS V L)]))
 EXPR)

(DEFPROP NCONC1 (LAMBDA (X Y) (NCONC X (LIST Y))) EXPR)

(DEFPROP ADDPROP (LAMBDA (A V I) (PUTPROP A (ENTER V (GET A I)) I)) EXPR)

(DEFPROP PUTLIST
 (LAMBDA (L V I) (MAPC (FUNCTION (LAMBDA (A) (PUTPROP A V I))) L))
 EXPR)

(DEFPROP REMLIST
 (LAMBDA (L I) (MAPC (FUNCTION (LAMBDA (A) (REMPROP A I))) L))
 EXPR)

(DEFPROP REMPROPS
 (LAMBDA (A L) (MAPC (FUNCTION (LAMBDA (I) (REMPROP A I))) L))
 EXPR)

(DEFPROP UNION
 (LAMBDA (L1 L2)
  (PROG (A Z)
   LOOP (COND [(NULL L1) (RETURN (OR A L2))]
	      [(MEMBFN (CAR L1) (OR A L2))]
	      [(NULL A) (SETQ A (SETQ Z (CONS (CAR L1) L2)))]
	      [T (SETQ Z (CDR (RPLACD Z (CONS (CAR L1) L2))))])
	(SETQ L1 (CDR L1))
	(GO LOOP)))
 EXPR)

(DEFPROP INTERSECTION
 (LAMBDA (L1 L2)
  (PROG (A Z)
   LOOP (COND [(NULL L1) (RETURN A)]
	      [(NOT (MEMBFN (CAR L1) L2))]
	      [(NULL A) (SETQ A (SETQ Z (NCONS (CAR L1))))]
	      [T (SETQ Z (CDR (RPLACD Z (NCONS (CAR L1)))))])
	(SETQ L1 (CDR L1))
	(GO LOOP)))
 EXPR)

(DEFV MEMBFN MEMBER)

(DEFPROP INSERT
 (LAMBDA (X L COMPAREFN NODUPS)
  {;; INSERT uses a binary search to insert X into L; The INSERT MERGE and SORT
      routines were copied virtually unchanged from the CMU LISPX package⎇
  (COND
   [(NULL L) (LIST X)]
   [(ATOM L) (ERROR (LIST L '"CAN'T INSERT INTO ATOM"))]
   [T (AND [NULL COMPAREFN] [SETQ COMPAREFN 'LEXORDER])
      (PROG (L1 N N1 Y)
	    (SETQ L1 L)
	    (SETQ N (LENGTH L))
	  A (SETQ N1 (*QUO (ADD1 N) 2.))
	    (SETQ Y (FNTH L1 N1))
	    (COND [(*LESS N 3.)
		   (COND [(COMPAREFN X (CAR Y))
			  (COND [(NOT (AND NODUPS [EQUAL X (CAR Y)]))
				 (RPLACD Y (CONS (CAR Y) (CDR Y)))
				 (RPLACA Y X)])]
			 [(EQ N 1.) (RPLACD Y (CONS X (CDR Y)))]
			 [(COMPAREFN X (CADR Y))
			  (COND [(NOT (AND NODUPS [EQUAL X (CADR Y)]))
				 (RPLACD (CDR Y) (CONS (CADR Y) (CDDR Y)))
				 (RPLACA (CDR Y) X)])]
			 [T (RPLACD (CDR Y) (CONS X (CDDR Y)))])]
		  [(COMPAREFN X (CAR Y))
		   (COND [(NOT (AND NODUPS [EQUAL X (CAR Y)]))
			  (SETQ N (SUB1 N1))
			  (GO A)])]
		  [T (SETQ L1 (CDR Y)) (SETQ N (*DIF N N1)) (GO A)]))
      L]))
 EXPR)

(DEFPROP MERGE
 (LAMBDA (X Y COMPAREFN NODUPS)
  (PROG (U Z)
	(SETQ Z (NCONS NIL))
	(AND [NULL COMPAREFN] [SETQ COMPAREFN 'LEXORDER])
      A (COND [(NULL X) (GO B)]
	      [(NULL Y) (SETQ Y X) (GO B)]
	      [(COMPAREFN (CAR X) (CAR Y)) (SETQ U (CAR X)) (SETQ X (CDR X))]
	      [T (SETQ U (CAR Y)) (SETQ Y (CDR Y))])
	(COND [(OR [NOT NODUPS] [NOT (EQUAL (CADR Z) U)]) (TCONC Z U)])
	(GO A)
      B (COND [(NULL Y) (RETURN (CAR Z))]
	      [T (COND [(OR [NOT NODUPS] [NOT (EQUAL (CADR Z) (CAR Y))])
			(TCONC Z (CAR Y))])
		 (SETQ Y (CDR Y))
		 (GO B)])))
 EXPR)

(DEFPROP SORT
 (LAMBDA (X COMPAREFN NODUPS)
  (PROG (Z)
	(COND [(ATOM X) (RETURN X)] [T (SETQ Z (NCONS (CAR X)))])
	(AND [NULL COMPAREFN] [SETQ COMPAREFN 'LEXORDER])
      A (COND [(NULL (SETQ X (CDR X))) (RETURN Z)]
	      [T (INSERT (CAR X) Z COMPAREFN NODUPS) (GO A)])))
 EXPR)

{;; A fast version of NTH for those who know what they are doing:⎇

(LAP FNTH SUBR)
	(PUSH P 1.)
	(MOVE 1. 2.)
	(PUSHJ P NUMVAL)
	(MOVE 2. 1.)
	(POP P 1.)
 TAG1	(CAIN 2. 1.)
	(POPJ P)
	(SUB 2. (C 0. 0. 1. 0.))
	(HRRZ@ 1. 1.)
	(JRST 0. TAG1)
	NIL

{;; New functions on strings:⎇

(DEFPROP SUBSTRING
 (LAMBDA (STR S E)
  (PROG (LEN NEWSTR)
	(SETQ LEN (LENGTH (SETQ NEWSTR (AEXPLODEC STR))))
	(SETQ S (%SUBSTR S 1. 1. LEN))
	(SETQ E (%SUBSTR E LEN S LEN))
	(COND [(NEQ E LEN)
	       (FREELIST (CDR (SETQ E (FNTH NEWSTR E))))
	       (RPLACD E NIL)]
	      [T (SETQ E (LAST NEWSTR))])
	(RPLACD E '(34.))
	(RETURN (PROG1 (READLIST (SETQ S (CONS 34. (FNTH NEWSTR S))))
		       (RPLACD E NIL)
		       (FREE S)
		       (FREELIST NEWSTR)))))
 EXPR)

(DEFPROP %SUBSTR
 (LAMBDA (V I L H)
  (COND [(NOT (NUMBERP V)) (SETQ V I)]
	[(MINUSP V) (SETQ V (ADD1 (*PLUS H V)))])
  (COND [(OR [*LESS V L] [*GREAT V H]) (ERROR '"STRING TOO SHORT - SUBSTRING")])
  V)
 EXPR)

(DEFPROP CONCAT
 (LAMBDA (X Y)
  (PROG (L)
	(SETQ L (CONS 34. (NCONC (AEXPLODEC X) (AEXPLODEC Y) (LIST 34.))))
	(RETURN (PROG1 (READLIST L) (FREELIST L)))))
 EXPR)

{;; New mapping functions:⎇

(DEFPROP MAPATOMS
 (LAMBDA (%FN) (MAPC (FUNCTION (LAMBDA (%A) (MAPC %FN %A))) OBLIST))
 EXPR)

(DEFPROP EVERY
 (LAMBDA NARGS
  (PROG (FN ARGS)
	(SETQ FN (ARG 1.))
     LP (COND [(*GREAT NARGS 1.)
	       (SETQ ARGS (CONS (ARG NARGS) ARGS))
	       (SETQ NARGS (SUB1 NARGS))
	       (GO LP)])
	(SETQ NARGS (APPEND ARGS NIL)) {; Make arg list the proper length⎇
   LOOP (AND [MEMB NIL NARGS] [RETURN T])
	(MAP (FUNCTION
	      (LAMBDA (L1 L2)
	       (COND [(ATOM (CAR L1)) (ERROR '"NON-NULL TAIL - EVERY/SOME")])
	       (RPLACA L2 (CAAR L1))
	       (RPLACA L1 (CDAR L1))))
	     NARGS 
	     ARGS)
	(COND [(APPLY FN ARGS) (GO LOOP)] [T (RETURN NIL)])))
 EXPR)

(DEFPROP SOME
 (LAMBDA NARGS
  (PROG (FN ARGS ANS)
	(SETQ FN (ARG 1.))
     LP (COND [(*GREAT NARGS 1.)
	       (SETQ ARGS (CONS (ARG NARGS) ARGS))
	       (SETQ NARGS (SUB1 NARGS))
	       (GO LP)])
	(SETQ NARGS (APPEND ARGS NIL)) {; Make arg list the proper length⎇
   LOOP (AND [MEMB NIL NARGS] [RETURN NIL])
	(MAP (FUNCTION
	      (LAMBDA (L1 L2)
	       (COND [(ATOM (SETQ ANS (CAR L1)))
		      (ERROR '"NON-NULL TAIL - EVERY/SOME")])
	       (RPLACA L2 (CAAR L1))
	       (RPLACA L1 (CDAR L1))))
	     NARGS 
	     ARGS)
	(COND [(APPLY FN ARGS) (RETURN ANS)] [T (GO LOOP)])))
 EXPR)

(DEFPROP SUBSET
 (LAMBDA (FN L)
  (PROG (A)
	(SETQ A (NCONS NIL))
   LOOP (COND [(NULL L) (RETURN (CAR A))]
	      [(ATOM L) (ERROR '"NON-NULL TAIL - SUBSET")]
	      [(FN (CAR L)) (TCONC A (CAR L))])
	(SETQ L (CDR L))
	(GO LOOP)))
 EXPR)

{;; New functions for controlling evaluation:⎇

(DEFPROP THROW
 (LAMBDA (L)
  (SETQ THROW (EVAL (CAR L)))
  (SETQ CATCH (AND [CDR L] [CADR L]))
  (ERR 'THROW))
 FEXPR)

(DEFPROP CATCH
 (LAMBDA (L)
  (COND [(OR [%CATCH (ERRSET (EVAL (CAR L)))] [NULL (SETQ L (CDR L))])
	 THROW]
	[(ATOM (CAR L)) (COND [(EQ CATCH (CAR L)) THROW] [T (ERR 'THROW)])]
	[T (APPLY# 'SELECTQ (CONS 'CATCH (APPEND L '((ERR 'THROW)))))]))
 FEXPR)

(DEFPROP %CATCH
 (LAMBDA (V)
  {;; %CATCH is called from compiled code⎇
  (COND [(CONSP V) (SETQ THROW (CAR V)) (FREE V) T]
	[(NEQ V 'THROW) (ERR V)]))
 EXPR)

(DEFPROP TIMER
 (LAMBDA (%L)
  (PROG (%TIME %SPEAK %GCTIME %DTIME %V)
	(COND [%L (SETQ %TIME (TIME))
		  (SETQ %GCTIME (GCTIME))
		  (SETQ %DTIME (DTIME))
		  (SETQ %SPEAK (SPEAK))
		  (SETQ %V (APPLY# 'PROGN %L))]
	      [T (SETQ %TIME %%TIME)
		 (SETQ %GCTIME %%GCTIME)
		 (SETQ %DTIME %%DTIME)
		 (SETQ %SPEAK %%SPEAK)])
	(SETQ %SPEAK (*DIF (SPEAK) %SPEAK))
	(SETQ %TIME (*DIF (TIME) %TIME))
	(SETQ %GCTIME (*DIF (GCTIME) %GCTIME))
	(SETQ %DTIME (*DIF (DTIME) %DTIME))
	(PROG (BASE)
	      (SETQ BASE -10.)
	      (TTYMSG 0. %TIME " msec CPU (" %GCTIME " msec GC), " %DTIME
		      " msec clock, " %SPEAK " conses" T))
	(COND [(NULL %L)
	       (SETQ %%TIME (TIME))
	       (SETQ %%GCTIME (GCTIME))
	       (SETQ %%DTIME (DTIME))
	       (SETQ %%SPEAK (SPEAK))])
	(RETURN %V)))
 FEXPR)

(DEFV %%TIME 0.)

(DEFV %%DTIME 0.)

(DEFV %%GCTIME 0.)

(DEFV %%SPEAK 0.)

(DEFPROP BOUNDP
 (LAMBDA (X)
  (AND [LITATOM X] [SETQ X (GET X 'VALUE)] [NEQ (CDR X) (UNBOUND)]))
 EXPR)

{;; Core expansion functions:⎇

(DEFPROP EXPFS (LAMBDA (N) (REALLOC 0. 0. 0. 0. N)) EXPR)

(DEFPROP EXPFWS (LAMBDA (N) (REALLOC N 0. 0. 0. 0.)) EXPR)

(DEFPROP EXPBPS (LAMBDA (N) (REALLOC 0. N 0. 0. 0.)) EXPR)

{;; New IO functions:⎇

(DEFPROP GETDEF
 (LAMBDA (%L)
  {;; Fast GETDEF copied with some modifications from CMU; Scans for expressions
      starting in column 1.  with the function a member of GETDEF and the first
      argument a member of %L (must be space or CR following name)⎇
  (PROG (%D %F %R)
	(COND [(%DEVP (CAR %L)) (SETQ %D (CAR %L)) (SETQ %L (CDR %L))]
	      [T (SETQ %D 'DSK:)])
	(SETQ %D (INC (APPLY# 'INPUT (LIST (GENSYM) %D (CAR %L))) NIL))
	(SETQ %L (CDR %L))
	(LINES 0.)
	(SETQ %R
	 (ERRSET
	  (PROG (%C %X %Y)
	   LOOP (COND [(MEMB (SETQ %C (TYI)) '(10. 11. 12. 13.)) (GO LOOP)]
		      [(MEMB %C '(40. 91.))
		       (COND [(AND [LITATOM (SETQ %X (READ))]
				   [MEMB %X GETDEF]
				   [LITATOM (SETQ %Y (RDNAM))]
				   [OR [NEQ %Y (SETQ %Y (INTERN %Y))]
				       [APPLY# 'REMOB (NCONS %Y)]]
				   [MEMB %Y %L]
				   [NOT (MEMB (PEEKC) '(40. 91.))])
			      (UNTYI %C)
			      (UNBREAK! %Y)
			      (PRINA (EVAL (MCONS %X %Y (READ))))
			      (SPACES 1.)
			      (SETQ %F T)])])
		(COND [(NEQ (TYI) 10.) {; Give him an (old) comment char for
					  fast ignore of rest of line⎇
		       (UNTYI 25.)])
		(GO LOOP))
	  ERRORX))
	(LINES 0.)
	(INC %D T)
	(AND [NEQ %R '$EOF$] [ERR %R])
	(RETURN (COND [%F 'Functions-Loaded] [T 'None-Found]))))
 FEXPR)

(DEFV GETDEF (DEFPROP DEFP DEFV SETQ DE DF DM LAP DRM DSM))

(DEFPROP TYPE
 (LAMBDA (%F)
  (SETQ %F (INC (APPLY# 'INPUT (CONS (GENSYM) %F)) NIL))
  (LINES 0.)
  (ERRSET (PROG NIL LOOP (TYO (TYI)) (GO LOOP)))
  (LINES 0.)
  (INC %F T)
  (IASCII 0.))
 FEXPR)

(DEFPROP DIRF
 (LAMBDA (L)
  (PROG (%UFD %SPEC)
	(SETQ %SPEC '*)
	(COND [(NULL L) (GO OK)]
	      [(CDR L) (SETQ %SPEC (CADR L))]
	      [(NOT (%DEVP (CAR L))) (SETQ %SPEC (CAR L)) (GO OK)])
	(SETQ %UFD (CAR L))
     OK (SETQ %UFD (INC (UFDINP (GENSYM) %UFD) NIL))
	(AND [ATOM %SPEC] [SETQ %SPEC (CONS %SPEC '*)])
	(LINES 0.)
	(ERRSET (PROG (%FILE)
		 LOOP (SETQ %FILE (RDFILENAM))
		      (COND [(AND [OR [EQ (CAR %SPEC) '*]
				      [EQSTR (CAR %SPEC)
					     (COND [(ATOM %FILE) %FILE]
						   [T (CAR %FILE)])]]
				  [OR [EQ (CDR %SPEC) '*]
				      [AND [CONSP %FILE]
					   [EQSTR (CDR %SPEC) (CDR %FILE)]]])
			     (PRIN1 %FILE)
			     (TERPRI)])
		      (GO LOOP)))
	(INC %UFD T)
	(RETURN (IASCII 0.))))
 FEXPR)

(DEFPROP HGHIN
 (LAMBDA (L)
  (PROG (BPORG BPEND)
	(SETQ BPORG (HGHORG NIL))
	(SETQ BPEND (HGHEND))
	(SETQ L (ERRSET (APPLY# 'DSKIN L) ERRORX))
	(HGHORG BPORG)
	(HGHCOR NIL)
	(COND [(ATOM L) (ERR L)] [T (RETURN (CAR L))])))
 FEXPR)

(DEFPROP DUMPATOMS
 (LAMBDA (L)
  {;; The interesting thing here is to dump the atoms to be REMOBed in such a
      way that they can be restored even if the system is REALLOCated⎇
  (PROG (A D BASE *NOPOINT REMOBL)
	(SETQ BASE 8.)
	(SETQ *NOPOINT NIL)
	(OR L [SETQ L '((REMOB . LSP))])
	(SETQ L (OUTC (APPLY# 'OUTPUT (CONS (GENSYM) L)) NIL))
	(SETQ REMOBL (REVERSE REMOB))
   LOOP (COND [(NULL REMOBL) (GO DONE)]
	      [(MEMB (SETQ A (CAR REMOBL)) (SETQ REMOBL (CDR REMOBL)))
	       (SETQ REMOBL (DREMOVE A REMOBL))])
	(COND [(SETQ D (GETL A '(SUBR FSUBR LSUBR)))
	       (%DUMPATOMS A (LIST 'NUMVAL (MAKNUM (CADR D) 'FIXNUM)) (CAR D))])
	(COND [(SETQ D (GET A 'SYM)) (%DUMPATOMS A D 'SYM)])
	(COND [(SETQ D (GET A 'VALUE))
	       (%DUMPATOMS A 
			   (LIST 'NUMVAL
				 (LIST '*PLUS
				       (*DIF (MAKNUM D 'FIXNUM) (EXAMINE 9.))
				       '(EXAMINE 9.)))
			   'VALUE)
	       (AND [SETQ A (ASSOC D LAPLST)] [SETQ LAPLST (DREMOVE A LAPLST)])
	       (OR [MEMB D LAPSLST] [SETQ LAPSLST (CONS D LAPSLST)])])
	(GO LOOP)
   DONE (SPRINT (LIST 'DEFV 'REMOB REMOB) 1.)
	(TERPRI)
	(OUTC L T)
	(APPLY# 'REMOB REMOB)
	(SETQ REMOB NIL)))
 FEXPR)

(DEFPROP %DUMPATOMS
 (LAMBDA (A D P)
  (SPRINT (LIST 'PUTPROP (LIST 'QUOTE A) D (LIST 'QUOTE P)) 1.))
 EXPR)

(DEFPROP PRINA
 (LAMBDA (X COL)
  {;; PRINA and PRINAC use special vars to pass info to %PRINA in order to save
      stack space⎇
  (SETQ %%PACO (OR COL 1.))
  (SETQ %%PAFN 'PRIN1)
  (SETQ %%PAFS 'FLATSIZE)
  (%PRINA X))
 EXPR)

(DEFPROP PRINAC
 (LAMBDA (X COL)
  (SETQ %%PACO (OR COL 1.))
  (SETQ %%PAFN 'PRINC)
  (SETQ %%PAFS 'FLATSIZEC)
  (%PRINA X))
 EXPR)

(DEFPROP %PRINA
 (LAMBDA (X)
  (COND [(PATOM X)
	 (AND [*LESS (CHRCT) (*PLUS (%%PAFS X) 3.)] [TAB %%PACO])
	 (%%PAFN X)]
	[T (AND [*LESS (CHRCT) 14.] [TAB %%PACO])
	   (TYO 40.)
	   (PROG (L)
		 (SETQ L X)
	    LOOP (%PRINA (CAR L))
		 (COND [(PATOM (SETQ L (CDR L)))
			(COND [L (AND [*LESS (CHRCT) 3.] [TAB %%PACO])
				 (PRINC '" . ")
				 (%PRINA L)])
			(TYOA 41. %%PACO)
			(RETURN X)]
		       [T (SPACES 1. %%PACO) (GO LOOP)]))]))
 EXPR)

(DEFPROP PRINL
 (LAMBDA (L COL)
  (OR COL [SETQ COL 1.])
  (COND [(CONSP L)
	 (PRINA (CAR L) COL)
	 (MAPC (FUNCTION (LAMBDA (X) (SPACES 1. COL) (PRINA X COL))) (CDR L))])
  L)
 EXPR)

(DEFPROP PRINLC
 (LAMBDA (L COL)
  (OR COL [SETQ COL 1.])
  (COND [(CONSP L)
	 (PRINAC (CAR L) COL)
	 (MAPC (FUNCTION (LAMBDA (X) (SPACES 1. COL) (PRINAC X COL))) (CDR L))])
  L)
 EXPR)

(DEFPROP PRINTC (LAMBDA (X) (TERPRI) (PROG1 (PRINC X) (TYO 32.))) EXPR)

(DEFPROP TYOA
 (LAMBDA (N C) (AND [=0 (CHRCT)] [TAB (OR C 1.)]) (TYO N))
 EXPR)

(DEFPROP SPACES
 (LAMBDA (N COL)
  (COND [(*LESS (CHRCT) N) (TAB (OR COL 1.))]
	[(EQ N 1.) (TYO 32.)]
	[T (TAB (*PLUS (CHRPOS) N))])
  NIL)
 EXPR)

(DEFPROP MSG
 (LAMBDA (%L)
  (MAPC (FUNCTION
	 (LAMBDA (I)
	  (COND [(EQ I T) (TERPRI)]
		[(NUMBERP I)
		 (COND [(*LESS I 1.) (LINES (MINUS I))] [T (SPACES I)])]
		[(STRINGP I) (PRINAC I)]
		[(AND [CONSP I] [EQ (CAR I) 'E]) (EVAL (CADR I))]
		[(AND [CONSP I] [EQ (CAR I) 'T]) (TAB (EVAL (CADR I)))]
		[T (PRINA (EVAL I))])))
	%L))
 FEXPR)

(DEFPROP TTYMSG
 (LAMBDA (%L) (OUTC (PROG1 (OUTC NIL NIL) (TALK) (APPLY# 'MSG %L)) NIL))
 FEXPR)

(DEFPROP TTYIN
 (LAMBDA (L)
  (PROG (CH)
	(SETQ CH (INC NIL NIL))
	(RETURN (PROG1 (APPLY# 'PROGN L) (INC CH NIL)))))
 FEXPR)

(DEFPROP TTYOUT
 (LAMBDA (L)
  (PROG (CH)
	(SETQ CH (OUTC NIL NIL))
	(RETURN (PROG1 (APPLY# 'PROGN L) (OUTC CH NIL)))))
 FEXPR)

(DEFPROP PEEKC (LAMBDA NIL (UNTYI (TYI))) EXPR)

(DEFPROP DELIM
 (LAMBDA (%C) (EQ (BOOLE 1. 7. (LSH (MODCHR %C NIL) -22.)) 2.))
 EXPR)

(NOCOMPILE
(DEFV LISPFNS ((DECLARE (SPECIAL $%DOTFLG %%DTIME %%GCTIME %%PACO %%PAFN 
	       %%PAFS %%SPEAK %%TIME %PREVFN% *NOPOINT *NOPOINTDSK *RAISE 
	       *RAISEDSK ALLFNS ALLVALS BASE BPEND BPORG CATCH COMMENTFLG 
	       DSKIN DSKLENGTH DSKOUT EDITV FILBAK FILBAKBAK FILPRO GETDEF 
	       LAPLST LAPSLST LASTWORD MEMBFN NOCALL OBLIST PP PRINLEV REMOB 
	       SAVE THROW) (NOCALL SELECTQ1 SUBPR MEMCDR %FILEXT %PRINA 
	       %DUMPATOMS %SUBSTR %%PACO %%PAFN %%PAFS) (GLOBALMACRO PLUS 
	       DIFFERENCE TIMES QUOTIENT LESSP GREATERP MIN MAX MCONS PUSH 
	       POP INCR DECR NOTANY NOTEVERY F:L DO RPTQ)) (;; System macros 
	       and supporting functions:) (F: PLUS DIFFERENCE TIMES QUOTIENT 
	       LESSP GREATERP MIN MAX MCONS PUSH POP INCR DECR NOTANY 
	       NOTEVERY F:L DO RPTQ %DO *EXPAND2 UNMACEXPAND) (*PG*) 
	       (;; New names for old friends:) (DEFP + *PLUS SUBR) 
	       (DEFP - *DIF SUBR) (DEFP * *TIMES SUBR) (DEFP // *QUO SUBR) 
	       (DEFP +I ADD1 SUBR) (DEFP -I SUB1 SUBR) (DEFP = EQUAL SUBR) 
	       (DEFP LT *LESS SUBR) (DEFP GT *GREAT SUBR) (DEFP PUT PUTPROP 
	       SUBR) (DEFP PRIN PRIN1 SUBR) (DEFP READL LINEREAD SUBR) 
	       (DEFP MAPL MAPLIST LSUBR) (DEFP MAPCL MAPCAR LSUBR) 
	       (DEFP CONSCOUNT SPEAK SUBR) (*PG*) (;; Original UCI LISP 
	       functions <with Rutgers modifications>:) (F: DIR *RENAME 
	       FILBAK %FILEXT (V: FILBAK FILBAKBAK) DE DF DM DV %DEFINE 
	       (V: (SAVE T) (ALLFNS NIL) (ALLVALS NIL)) SAVE UNSAVE DRM DSM 
	       %DEREAD DSKIN (V: (DSKIN T)) %READIN (V: (*RAISEDSK NIL)) 
	       DSKOUT (V: (DSKOUT T) (*NOPOINTDSK NIL) (DSKLENGTH 80.)) 
	       (PROGN (REMPROP (QUOTE LPTLENGTH) (QUOTE VALUE)) (DEFP 
	       LPTLENGTH DSKLENGTH VALUE)) %DEVP TCONC LCONC DREVERSE REMOVE 
	       DREMOVE TAILP ASSOC# PRINTLEV PRINLEV (V: PRINLEV) MEMCDR 
	       (V: (%PREVFN% NIL) ($%DOTFLG NIL)) LSUBST SELECTQ SELECTQ1 
	       SUBLIS SUBPAIR SUBPR DSUBST RETFROM LDIFF NTH SUBST COPY 
	       PUTSYM GETSYM RPUTSYM RGETSYM) (*PG*) (;; Rutgers additions:) 
	       (;; New predicates:) (F: LE GE =0 INP) (;; New 
	       list-manipulation and property list functions:) (F: ATTACH 
	       ENTER NCONC1 ADDPROP PUTLIST REMLIST REMPROPS UNION 
	       INTERSECTION (V: MEMBFN) INSERT MERGE SORT (;; A fast version 
	       of NTH for those who know what they are doing:) ((LAP FNTH 
	       SUBR) (PUSH P 1.) (MOVE 1. 2.) (PUSHJ P NUMVAL) (MOVE 2. 1.) 
	       (POP P 1.) TAG1 (CAIN 2. 1.) (POPJ P) (SUB 2. (C 0. 0. 1. 0.)) 
	       (HRRZ@ 1. 1.) (JRST 0. TAG1) NIL)) (;; New functions on 
	       strings:) (F: SUBSTRING %SUBSTR CONCAT) (;; New mapping 
	       functions:) (F: MAPATOMS EVERY SOME SUBSET) (;; New functions 
	       for controlling evaluation:) (F: THROW CATCH %CATCH TIMER 
	       (V: (%%TIME 0.) (%%DTIME 0.) (%%GCTIME 0.) (%%SPEAK 0.)) 
	       BOUNDP) (;; Core expansion functions:) (F: EXPFS EXPFWS EXPBPS) 
	       (;; New IO functions:) (F: GETDEF (V: GETDEF) TYPE DIRF HGHIN 
	       DUMPATOMS %DUMPATOMS PRINA PRINAC %PRINA PRINL PRINLC PRINTC 
	       TYOA SPACES MSG TTYMSG TTYIN TTYOUT PEEKC DELIM)))
)